home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / File / Copy.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  15.7 KB  |  522 lines
  1. # File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This
  2. # source code has been placed in the public domain by the author.
  3. # Please be kind and preserve the documentation.
  4. #
  5. # Additions copyright 1996 by Charles Bailey.  Permission is granted
  6. # to distribute the revised code under the same terms as Perl itself.
  7.  
  8. package File::Copy;
  9.  
  10. use 5.006;
  11. use strict;
  12. use warnings;
  13. use File::Spec;
  14. use Config;
  15. our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
  16. sub copy;
  17. sub syscopy;
  18. sub cp;
  19. sub mv;
  20.  
  21. # Note that this module implements only *part* of the API defined by
  22. # the File/Copy.pm module of the File-Tools-2.0 package.  However, that
  23. # package has not yet been updated to work with Perl 5.004, and so it
  24. # would be a Bad Thing for the CPAN module to grab it and replace this
  25. # module.  Therefore, we set this module's version higher than 2.0.
  26. $VERSION = '2.11';
  27.  
  28. require Exporter;
  29. @ISA = qw(Exporter);
  30. @EXPORT = qw(copy move);
  31. @EXPORT_OK = qw(cp mv);
  32.  
  33. $Too_Big = 1024 * 1024 * 2;
  34.  
  35. sub croak {
  36.     require Carp;
  37.     goto &Carp::croak;
  38. }
  39.  
  40. sub carp {
  41.     require Carp;
  42.     goto &Carp::carp;
  43. }
  44.  
  45. my $macfiles;
  46. if ($^O eq 'MacOS') {
  47.     $macfiles = eval { require Mac::MoreFiles };
  48.     warn 'Mac::MoreFiles could not be loaded; using non-native syscopy'
  49.         if $@ && $^W;
  50. }
  51.  
  52. sub _catname {
  53.     my($from, $to) = @_;
  54.     if (not defined &basename) {
  55.     require File::Basename;
  56.     import  File::Basename 'basename';
  57.     }
  58.  
  59.     if ($^O eq 'MacOS') {
  60.     # a partial dir name that's valid only in the cwd (e.g. 'tmp')
  61.     $to = ':' . $to if $to !~ /:/;
  62.     }
  63.  
  64.     return File::Spec->catfile($to, basename($from));
  65. }
  66.  
  67. # _eq($from, $to) tells whether $from and $to are identical
  68. # works for strings and references
  69. sub _eq {
  70.     return $_[0] == $_[1] if ref $_[0] && ref $_[1];
  71.     return $_[0] eq $_[1] if !ref $_[0] && !ref $_[1];
  72.     return "";
  73. }
  74.  
  75. sub copy {
  76.     croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
  77.       unless(@_ == 2 || @_ == 3);
  78.  
  79.     my $from = shift;
  80.     my $to = shift;
  81.  
  82.     my $from_a_handle = (ref($from)
  83.              ? (ref($from) eq 'GLOB'
  84.                 || UNIVERSAL::isa($from, 'GLOB')
  85.                             || UNIVERSAL::isa($from, 'IO::Handle'))
  86.              : (ref(\$from) eq 'GLOB'));
  87.     my $to_a_handle =   (ref($to)
  88.              ? (ref($to) eq 'GLOB'
  89.                 || UNIVERSAL::isa($to, 'GLOB')
  90.                             || UNIVERSAL::isa($to, 'IO::Handle'))
  91.              : (ref(\$to) eq 'GLOB'));
  92.  
  93.     if (_eq($from, $to)) { # works for references, too
  94.     carp("'$from' and '$to' are identical (not copied)");
  95.         # The "copy" was a success as the source and destination contain
  96.         # the same data.
  97.         return 1;
  98.     }
  99.  
  100.     if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
  101.     !($^O eq 'MSWin32' || $^O eq 'os2')) {
  102.     my @fs = stat($from);
  103.     if (@fs) {
  104.         my @ts = stat($to);
  105.         if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) {
  106.         carp("'$from' and '$to' are identical (not copied)");
  107.                 return 0;
  108.         }
  109.     }
  110.     }
  111.  
  112.     if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
  113.     $to = _catname($from, $to);
  114.     }
  115.  
  116.     if (defined &syscopy && !$Syscopy_is_copy
  117.     && !$to_a_handle
  118.     && !($from_a_handle && $^O eq 'os2' )    # OS/2 cannot handle handles
  119.     && !($from_a_handle && $^O eq 'mpeix')    # and neither can MPE/iX.
  120.     && !($from_a_handle && $^O eq 'MSWin32')
  121.     && !($from_a_handle && $^O eq 'MacOS')
  122.     && !($from_a_handle && $^O eq 'NetWare')
  123.        )
  124.     {
  125.     my $copy_to = $to;
  126.  
  127.         if ($^O eq 'VMS' && -e $from) {
  128.  
  129.             if (! -d $to && ! -d $from) {
  130.  
  131.                 # VMS has sticky defaults on extensions, which means that
  132.                 # if there is a null extension on the destination file, it
  133.                 # will inherit the extension of the source file
  134.                 # So add a '.' for a null extension.
  135.  
  136.                 $copy_to = VMS::Filespec::vmsify($to);
  137.                 my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to);
  138.                 $file = $file . '.' unless ($file =~ /(?<!\^)\./);
  139.                 $copy_to = File::Spec->catpath($vol, $dirs, $file);
  140.  
  141.                 # Get rid of the old versions to be like UNIX
  142.                 1 while unlink $copy_to;
  143.             }
  144.         }
  145.  
  146.         return syscopy($from, $copy_to);
  147.     }
  148.  
  149.     my $closefrom = 0;
  150.     my $closeto = 0;
  151.     my ($size, $status, $r, $buf);
  152.     local($\) = '';
  153.  
  154.     my $from_h;
  155.     if ($from_a_handle) {
  156.        $from_h = $from;
  157.     } else {
  158.     $from = _protect($from) if $from =~ /^\s/s;
  159.        $from_h = \do { local *FH };
  160.        open($from_h, "< $from\0") or goto fail_open1;
  161.        binmode $from_h or die "($!,$^E)";
  162.     $closefrom = 1;
  163.     }
  164.  
  165.     my $to_h;
  166.     if ($to_a_handle) {
  167.        $to_h = $to;
  168.     } else {
  169.     $to = _protect($to) if $to =~ /^\s/s;
  170.        $to_h = \do { local *FH };
  171.        open($to_h,"> $to\0") or goto fail_open2;
  172.        binmode $to_h or die "($!,$^E)";
  173.     $closeto = 1;
  174.     }
  175.  
  176.     if (@_) {
  177.     $size = shift(@_) + 0;
  178.     croak("Bad buffer size for copy: $size\n") unless ($size > 0);
  179.     } else {
  180.     $size = tied(*$from_h) ? 0 : -s $from_h || 0;
  181.     $size = 1024 if ($size < 512);
  182.     $size = $Too_Big if ($size > $Too_Big);
  183.     }
  184.  
  185.     $! = 0;
  186.     for (;;) {
  187.     my ($r, $w, $t);
  188.        defined($r = sysread($from_h, $buf, $size))
  189.         or goto fail_inner;
  190.     last unless $r;
  191.     for ($w = 0; $w < $r; $w += $t) {
  192.            $t = syswrite($to_h, $buf, $r - $w, $w)
  193.         or goto fail_inner;
  194.     }
  195.     }
  196.  
  197.     close($to_h) || goto fail_open2 if $closeto;
  198.     close($from_h) || goto fail_open1 if $closefrom;
  199.  
  200.     # Use this idiom to avoid uninitialized value warning.
  201.     return 1;
  202.  
  203.     # All of these contortions try to preserve error messages...
  204.   fail_inner:
  205.     if ($closeto) {
  206.     $status = $!;
  207.     $! = 0;
  208.        close $to_h;
  209.     $! = $status unless $!;
  210.     }
  211.   fail_open2:
  212.     if ($closefrom) {
  213.     $status = $!;
  214.     $! = 0;
  215.        close $from_h;
  216.     $! = $status unless $!;
  217.     }
  218.   fail_open1:
  219.     return 0;
  220. }
  221.  
  222. sub move {
  223.     croak("Usage: move(FROM, TO) ") unless @_ == 2;
  224.  
  225.     my($from,$to) = @_;
  226.  
  227.     my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
  228.  
  229.     if (-d $to && ! -d $from) {
  230.     $to = _catname($from, $to);
  231.     }
  232.  
  233.     ($tosz1,$tomt1) = (stat($to))[7,9];
  234.     $fromsz = -s $from;
  235.     if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
  236.       # will not rename with overwrite
  237.       unlink $to;
  238.     }
  239.  
  240.     my $rename_to = $to;
  241.     if (-$^O eq 'VMS' && -e $from) {
  242.  
  243.         if (! -d $to && ! -d $from) {
  244.             # VMS has sticky defaults on extensions, which means that
  245.             # if there is a null extension on the destination file, it
  246.             # will inherit the extension of the source file
  247.             # So add a '.' for a null extension.
  248.  
  249.             $rename_to = VMS::Filespec::vmsify($to);
  250.             my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to);
  251.             $file = $file . '.' unless ($file =~ /(?<!\^)\./);
  252.             $rename_to = File::Spec->catpath($vol, $dirs, $file);
  253.  
  254.             # Get rid of the old versions to be like UNIX
  255.             1 while unlink $rename_to;
  256.         }
  257.     }
  258.  
  259.     return 1 if rename $from, $rename_to;
  260.  
  261.     # Did rename return an error even though it succeeded, because $to
  262.     # is on a remote NFS file system, and NFS lost the server's ack?
  263.     return 1 if defined($fromsz) && !-e $from &&           # $from disappeared
  264.                 (($tosz2,$tomt2) = (stat($to))[7,9]) &&    # $to's there
  265.                   ((!defined $tosz1) ||               #  not before or
  266.            ($tosz1 != $tosz2 or $tomt1 != $tomt2)) &&  #   was changed
  267.                 $tosz2 == $fromsz;                         # it's all there
  268.  
  269.     ($tosz1,$tomt1) = (stat($to))[7,9];  # just in case rename did something
  270.  
  271.     {
  272.         local $@;
  273.         eval {
  274.             local $SIG{__DIE__};
  275.             copy($from,$to) or die;
  276.             my($atime, $mtime) = (stat($from))[8,9];
  277.             utime($atime, $mtime, $to);
  278.             unlink($from)   or die;
  279.         };
  280.         return 1 unless $@;
  281.     }
  282.     ($sts,$ossts) = ($! + 0, $^E + 0);
  283.  
  284.     ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
  285.     unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
  286.     ($!,$^E) = ($sts,$ossts);
  287.     return 0;
  288. }
  289.  
  290. *cp = \©
  291. *mv = \&move;
  292.  
  293.  
  294. if ($^O eq 'MacOS') {
  295.     *_protect = sub { MacPerl::MakeFSSpec($_[0]) };
  296. } else {
  297.     *_protect = sub { "./$_[0]" };
  298. }
  299.  
  300. # &syscopy is an XSUB under OS/2
  301. unless (defined &syscopy) {
  302.     if ($^O eq 'VMS') {
  303.     *syscopy = \&rmscopy;
  304.     } elsif ($^O eq 'mpeix') {
  305.     *syscopy = sub {
  306.         return 0 unless @_ == 2;
  307.         # Use the MPE cp program in order to
  308.         # preserve MPE file attributes.
  309.         return system('/bin/cp', '-f', $_[0], $_[1]) == 0;
  310.     };
  311.     } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
  312.     # Win32::CopyFile() fill only work if we can load Win32.xs
  313.     *syscopy = sub {
  314.         return 0 unless @_ == 2;
  315.         return Win32::CopyFile(@_, 1);
  316.     };
  317.     } elsif ($macfiles) {
  318.     *syscopy = sub {
  319.         my($from, $to) = @_;
  320.         my($dir, $toname);
  321.  
  322.         return 0 unless -e $from;
  323.  
  324.         if ($to =~ /(.*:)([^:]+):?$/) {
  325.         ($dir, $toname) = ($1, $2);
  326.         } else {
  327.         ($dir, $toname) = (":", $to);
  328.         }
  329.  
  330.         unlink($to);
  331.         Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1);
  332.     };
  333.     } else {
  334.     $Syscopy_is_copy = 1;
  335.     *syscopy = \©
  336.     }
  337. }
  338.  
  339. 1;
  340.  
  341. __END__
  342.  
  343. =head1 NAME
  344.  
  345. File::Copy - Copy files or filehandles
  346.  
  347. =head1 SYNOPSIS
  348.  
  349.     use File::Copy;
  350.  
  351.     copy("file1","file2") or die "Copy failed: $!";
  352.     copy("Copy.pm",\*STDOUT);
  353.     move("/dev1/fileA","/dev2/fileB");
  354.  
  355.     use File::Copy "cp";
  356.  
  357.     $n = FileHandle->new("/a/file","r");
  358.     cp($n,"x");
  359.  
  360. =head1 DESCRIPTION
  361.  
  362. The File::Copy module provides two basic functions, C<copy> and
  363. C<move>, which are useful for getting the contents of a file from
  364. one place to another.
  365.  
  366. =over 4
  367.  
  368. =item copy
  369. X<copy> X<cp>
  370.  
  371. The C<copy> function takes two
  372. parameters: a file to copy from and a file to copy to. Either
  373. argument may be a string, a FileHandle reference or a FileHandle
  374. glob. Obviously, if the first argument is a filehandle of some
  375. sort, it will be read from, and if it is a file I<name> it will
  376. be opened for reading. Likewise, the second argument will be
  377. written to (and created if need be).  Trying to copy a file on top
  378. of itself is a fatal error.
  379.  
  380. B<Note that passing in
  381. files as handles instead of names may lead to loss of information
  382. on some operating systems; it is recommended that you use file
  383. names whenever possible.>  Files are opened in binary mode where
  384. applicable.  To get a consistent behaviour when copying from a
  385. filehandle to a file, use C<binmode> on the filehandle.
  386.  
  387. An optional third parameter can be used to specify the buffer
  388. size used for copying. This is the number of bytes from the
  389. first file, that will be held in memory at any given time, before
  390. being written to the second file. The default buffer size depends
  391. upon the file, but will generally be the whole file (up to 2MB), or
  392. 1k for filehandles that do not reference files (eg. sockets).
  393.  
  394. You may use the syntax C<use File::Copy "cp"> to get at the
  395. "cp" alias for this function. The syntax is I<exactly> the same.
  396.  
  397. =item move
  398. X<move> X<mv> X<rename>
  399.  
  400. The C<move> function also takes two parameters: the current name
  401. and the intended name of the file to be moved.  If the destination
  402. already exists and is a directory, and the source is not a
  403. directory, then the source file will be renamed into the directory
  404. specified by the destination.
  405.  
  406. If possible, move() will simply rename the file.  Otherwise, it copies
  407. the file to the new location and deletes the original.  If an error occurs
  408. during this copy-and-delete process, you may be left with a (possibly partial)
  409. copy of the file under the destination name.
  410.  
  411. You may use the "mv" alias for this function in the same way that
  412. you may use the "cp" alias for C<copy>.
  413.  
  414. =item syscopy
  415. X<syscopy>
  416.  
  417. File::Copy also provides the C<syscopy> routine, which copies the
  418. file specified in the first parameter to the file specified in the
  419. second parameter, preserving OS-specific attributes and file
  420. structure.  For Unix systems, this is equivalent to the simple
  421. C<copy> routine, which doesn't preserve OS-specific attributes.  For
  422. VMS systems, this calls the C<rmscopy> routine (see below).  For OS/2
  423. systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
  424. this calls C<Win32::CopyFile>.
  425.  
  426. On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>,
  427. if available.
  428.  
  429. B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
  430.  
  431. If both arguments to C<copy> are not file handles,
  432. then C<copy> will perform a "system copy" of
  433. the input file to a new output file, in order to preserve file
  434. attributes, indexed file structure, I<etc.>  The buffer size
  435. parameter is ignored.  If either argument to C<copy> is a
  436. handle to an opened file, then data is copied using Perl
  437. operators, and no effort is made to preserve file attributes
  438. or record structure.
  439.  
  440. The system copy routine may also be called directly under VMS and OS/2
  441. as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
  442. is the routine that does the actual work for syscopy).
  443.  
  444. =item rmscopy($from,$to[,$date_flag])
  445. X<rmscopy>
  446.  
  447. The first and second arguments may be strings, typeglobs, typeglob
  448. references, or objects inheriting from IO::Handle;
  449. they are used in all cases to obtain the
  450. I<filespec> of the input and output files, respectively.  The
  451. name and type of the input file are used as defaults for the
  452. output file, if necessary.
  453.  
  454. A new version of the output file is always created, which
  455. inherits the structure and RMS attributes of the input file,
  456. except for owner and protections (and possibly timestamps;
  457. see below).  All data from the input file is copied to the
  458. output file; if either of the first two parameters to C<rmscopy>
  459. is a file handle, its position is unchanged.  (Note that this
  460. means a file handle pointing to the output file will be
  461. associated with an old version of that file after C<rmscopy>
  462. returns, not the newly created version.)
  463.  
  464. The third parameter is an integer flag, which tells C<rmscopy>
  465. how to handle timestamps.  If it is E<lt> 0, none of the input file's
  466. timestamps are propagated to the output file.  If it is E<gt> 0, then
  467. it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
  468. timestamps other than the revision date are propagated; if bit 1
  469. is set, the revision date is propagated.  If the third parameter
  470. to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
  471. if the name or type of the output file was explicitly specified,
  472. then no timestamps are propagated, but if they were taken implicitly
  473. from the input filespec, then all timestamps other than the
  474. revision date are propagated.  If this parameter is not supplied,
  475. it defaults to 0.
  476.  
  477. Like C<copy>, C<rmscopy> returns 1 on success.  If an error occurs,
  478. it sets C<$!>, deletes the output file, and returns 0.
  479.  
  480. =back
  481.  
  482. =head1 RETURN
  483.  
  484. All functions return 1 on success, 0 on failure.
  485. $! will be set if an error was encountered.
  486.  
  487. =head1 NOTES
  488.  
  489. =over 4
  490.  
  491. =item *
  492.  
  493. On Mac OS (Classic), the path separator is ':', not '/', and the 
  494. current directory is denoted as ':', not '.'. You should be careful 
  495. about specifying relative pathnames. While a full path always begins 
  496. with a volume name, a relative pathname should always begin with a 
  497. ':'.  If specifying a volume name only, a trailing ':' is required.
  498.  
  499. E.g.
  500.  
  501.   copy("file1", "tmp");        # creates the file 'tmp' in the current directory
  502.   copy("file1", ":tmp:");      # creates :tmp:file1
  503.   copy("file1", ":tmp");       # same as above
  504.   copy("file1", "tmp");        # same as above, if 'tmp' is a directory (but don't do
  505.                                # that, since it may cause confusion, see example #1)
  506.   copy("file1", "tmp:file1");  # error, since 'tmp:' is not a volume
  507.   copy("file1", ":tmp:file1"); # ok, partial path
  508.   copy("file1", "DataHD:");    # creates DataHD:file1
  509.  
  510.   move("MacintoshHD:fileA", "DataHD:fileB"); # moves (doesn't copy) files from one
  511.                                              # volume to another
  512.  
  513. =back
  514.  
  515. =head1 AUTHOR
  516.  
  517. File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
  518. and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
  519.  
  520. =cut
  521.  
  522.